home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SIMPLIFY.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  10.9 KB  |  428 lines
  1. ; SIMLIFY.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Program Simplification                *
  12. ;*        (for use only after alpha conversion)            *
  13. ;*                                    *
  14. ;*----------------------------------------------------------------------*
  15. ;*                                    *
  16. ;* Created by: David Bartley        Date: Oct 1985            *
  17. ;* Revision history:                            *
  18. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. (define pcs-simplify
  24.   (lambda (exp)
  25.     (letrec
  26. ;-------!
  27.  ((simp
  28.    (lambda (x)
  29.      (if (atom? x)
  30.      x
  31.      (case (car x)
  32.        (quote           x)
  33.        (#!TOKEN            x)                ; ID record
  34.        (lambda          (simp-lambda x))
  35.        (if              (simp-if (simp (if-pred x))
  36.                      (simp (if-then x))
  37.                      (simp (if-else x))))
  38.        (set!            (simp-set! (set!-id x)
  39.                        (simp (set!-exp x))))
  40.        (begin           (simp-begin (simp-args (cdr x) '())))
  41.        (letrec          (simp-letrec
  42.                  (simp-pairs (letrec-pairs x) '())
  43.                  (simp (letrec-body x))))
  44.        (else            (simp-application (simp-args x '())))
  45.        ))))
  46.  
  47.   (simp-lambda
  48.    (lambda (x)    ; note: preserve extra slots in the node
  49.      (begin       ;    This changes the apparent output of PME!!
  50.        (set-lambda-body x (simp (lambda-body x)))
  51.        x)))
  52.  
  53.   (simp-if
  54.    (lambda (p th el)
  55.      (cond                  ;; --- (if p (if p a b) c) ==> (if p a c)
  56.  
  57.            ((and (eq? (car th) 'if)
  58.          (dupe? p)            ; no side effects
  59.          (equal? p (if-pred th)))
  60.         (simp-if p (if-then th) el))
  61.  
  62.                   ;; --- (if p a (if p b c)) ==> (if p a c)
  63.  
  64.        ((and (eq? (car el) 'if)
  65.          (dupe? p)            ; no side effects
  66.          (equal? p (if-pred el)))
  67.         (simp-if p th (if-else el)))
  68.  
  69.                       ;; --- (if #F a b) ==> b
  70.                       ;; --- (if '* a b) ==> a
  71.  
  72.        ((eq? (car p) 'quote)
  73.         (if (cadr p) th el))
  74.  
  75.                       ;; --- (if (not a) b c) ==> (if a c b)
  76.  
  77.        ((eq? (car p) 'not)
  78.         (simp-if (cadr p) el th))
  79.  
  80.                       ;; --- (if (begin ... p) a b)
  81.                       ;; ==> (begin ... (if p a b))
  82.  
  83.        ((eq? (car p) 'begin)
  84.         (let ((sl (reverse (cdr p))))
  85.           (simp-begin
  86.            (%reverse! (cons (simp-if (car sl) th el)
  87.                    (cdr sl))))))
  88.  
  89.                       ;; --- (if (if a b c) d e)
  90.                       ;;
  91.                       ;; ==> (if a (if b d e)
  92.                       ;;           (if c d e))
  93.  
  94.        ((eq? (car p) 'if)
  95.         (cond ((dupe? th)
  96.            (let ((a (if-pred p))
  97.              (b (if-then p))
  98.              (c (if-else p)))
  99.              (cond
  100.                       ;; --- (if (if a 't c) d e)
  101.                   ;; ==> (if a d (if c d e))
  102.  
  103.                   ((and (pair? b)
  104.                 (eq? (car b) 'QUOTE)
  105.                 (cadr b))
  106.                (simp-if a th
  107.                       (simp-if c th el)))
  108.  
  109.                       ;; --- (if (if a b 't) d e)
  110.                   ;; ==> (if a (if b d e) d)
  111.  
  112.                   ((and (pair? c)
  113.                 (eq? (car c) 'QUOTE)
  114.                 (cadr c))
  115.                (simp-if a (simp-if b th el) th))
  116.  
  117.                       ;; --- (if (if a a c) d e)
  118.                   ;; ==> (if a d (if c d e))
  119.  
  120.               ((and (dupe? a)(equal? a b))
  121.                (simp-if a th (simp-if c th el)))
  122.  
  123.               (else
  124.                (list 'if p th el)))))
  125.  
  126.     ;; The following turns out to "pessimize" the code
  127.     ;; given the current code generator algorithms
  128.  
  129.     ;;      ((dupe? el)
  130.     ;;       (let ((a (if-pred p))
  131.     ;;         (b (if-then p))
  132.     ;;         (c (if-else p)))
  133.     ;;         (cond
  134.                       ;; --- (if (if a #F c) d e)
  135.                   ;; ==> (if a e (if c d e))
  136.  
  137.     ;;          ((equal? b '(quote #F))
  138.     ;;           (simp-if a el (simp-if c th el)))
  139.  
  140.                       ;; --- (if (if a b #F) d e)
  141.                   ;; ==> (if a (if b d e) e)
  142.  
  143.     ;;          ((equal? c '(quote #F))
  144.     ;;           (simp-if a (simp-if b th el) el))
  145.     ;;          (else
  146.     ;;             (list 'if p th el)))))
  147.  
  148.           (else
  149.            (list 'if p th el))))
  150.  
  151.        (else
  152.         (list 'if p th el)))))
  153.  
  154.   (dupe?
  155.    (lambda (x)
  156.      (or (atom? x)
  157.      (memq (car x) '(#!TOKEN QUOTE %%get-global%% %%get-fluid%%)))))
  158.  
  159.   (simp-set!
  160.    (lambda (id exp)
  161.      (cond
  162.                       ;; --- (set! a a) ==> a
  163.  
  164.            ((eq? id exp) id)
  165.  
  166.                       ;; --- (set! x (if a b c))
  167.                       ;; ==> (if a (set! x b)(set! x c))
  168.  
  169.        ((eq? (car exp) 'if)
  170.         (simp-if (if-pred exp)
  171.              (simp-set! id (if-then exp))
  172.              (simp-set! id (if-else exp))))
  173.        (else
  174.         (list 'set! id exp)))))
  175.  
  176.   (simp-begin
  177.    (lambda (sl)
  178.      (let ((sl (s-begin (%reverse! sl) '())))
  179.        (cond ((null? sl) '(quote ()))
  180.          ((null? (cdr sl)) (car sl))
  181.          (else
  182.           (cons 'begin sl))))))
  183.  
  184.   (s-begin
  185.    (lambda (old new)
  186.      (if (null? old)
  187.      new
  188.      (let ((s (car old)))
  189.        (cond ((and new                ; not last exp
  190.                (memq (car s) '(#!TOKEN QUOTE LAMBDA %%get-global%% %%get-fluid%%)))
  191.           (s-begin (cdr old) new))        ; delete s
  192.          ((or (eq? (car s) 'begin)
  193.               (and new (no-se-op (car s))))
  194.           (s-begin (append! (%reverse! (cdr s))
  195.                     (cdr old))
  196.                new))
  197.          (else (s-begin (cdr old)
  198.                 (cons s new))))))))
  199.  
  200. ;  (simp-apply
  201. ;   (lambda (fun arg)
  202. ;     (cond
  203. ;                    ;; --- (apply (lambda (a ...) body) arg)
  204. ;                   ;; ==> (let ((L arg))
  205. ;                   ;;       (let ((a (car L))...) body))
  206. ;
  207. ;        ((and (eq? (car fun) 'lambda)
  208. ;         (not (negative? (lambda-nargs fun))))
  209. ;        (simp-apply-letrec
  210. ;            (lambda-bvl fun) (lambda-body fun) arg #F))
  211. ;
  212. ;       (else (list '%apply fun arg)))))
  213.  
  214. ;(simp-apply-letrec
  215. ;(lambda (bvl body arg dupe?)
  216. ;                ;; (apply (lambda () body) L)
  217. ;                ;; ==> (begin L body)
  218. ;  (if (null? bvl)
  219. ;     (simp-begin (list arg body))
  220. ;     (let ((a (car bvl)))
  221. ;       (cond
  222. ;                ;; (apply (lambda (a ...) body) (cons x y))
  223. ;                ;; ==> (let ((a x))
  224. ;                ;;       (apply (lambda (...) body) y))
  225. ;           ((eq? (car arg) 'cons)
  226. ;        (simp-letrec
  227. ;            `((,a ,(cadr arg)))
  228. ;            (simp-apply-letrec
  229. ;                (cdr bvl) body (caddr arg) #F)))
  230. ;
  231. ;                ;; (apply (lambda (a) body) L)
  232. ;                ;; ==> (let ((a (car L))) body)
  233. ;           ((null? (cdr bvl))
  234. ;        (simp-letrec
  235. ;            `((,a (car ,arg)))
  236. ;               body))
  237. ;                ;; (apply (lambda (a...) body) triv)
  238. ;                ;; ==> (let ((a (car triv)))
  239. ;                ;;       (apply (lambda (...) body)
  240. ;                ;;              (cdr triv)))
  241. ;           ((or dupe?
  242. ;            (memq (car arg) '(#!TOKEN QUOTE)))
  243. ;        (simp-letrec
  244. ;            `((,a (car ,arg)))
  245. ;               (simp-apply-letrec
  246. ;               (cdr bvl) body `(cdr ,arg) 't)))
  247. ;
  248. ;                ;; (apply (lambda (a...) body) L)
  249. ;                ;; ==> (let ((temp L))
  250. ;                ;;       (let ((a (car L)))
  251. ;                ;;         (apply (lambda (...) body)
  252. ;                ;;                (cdr temp))))
  253. ;           (else
  254. ;        (let ((temp (pcs-make-id '())))
  255. ;          (simp-letrec
  256. ;              `((,temp ,arg))
  257. ;                 (simp-letrec
  258. ;                 `((,a (car ,temp)))
  259. ;                    (simp-apply-letrec
  260. ;                    (cdr bvl) body `(cdr ,temp) 't)))))
  261. ;           )))))
  262.  
  263.   (simp-letrec
  264.    (lambda (pairs body)
  265.      (cond
  266.                    ;; --- (letrec () body) ==> body
  267.  
  268.        ((and (null? pairs)
  269.          (not debug-mode))
  270.         body)
  271.  
  272.                    ;; --- (letrec ((a '*)...)
  273.                    ;;         (begin (set! a value) ...))
  274.                    ;; --- (letrec (...(a value))
  275.                    ;;         (begin ...))
  276.  
  277. ; omit: works, but not worth doing
  278. ;       ((and (eq? (car body) 'begin)
  279. ;         (eq? (car (cadr body)) 'set!)
  280. ;         (eq? (set!-id (cadr body)) (caar pairs))
  281. ;         (eq? (car (cadar pairs)) 'quote)
  282. ;         (memq (car (set!-exp (cadr body)))
  283. ;               '(quote  lambda)))
  284. ;        (simp-letrec
  285. ;        (append (cdr pairs)
  286. ;            (list
  287. ;                 (list (caar pairs)
  288. ;                   (set!-exp (cadr body)))))
  289. ;        (simp-begin
  290. ;            (cddr body))))
  291.  
  292.                    ;; --- (letrec ((a '*)...)
  293.                    ;;         (set! a value))
  294.                    ;; --- (letrec (...(a value))
  295.                    ;;         a)
  296.  
  297. ; omit: works, but not worth doing
  298. ;       ((and (eq? (car body) 'set!)
  299. ;         (eq? (set!-id body) (caar pairs))
  300. ;         (eq? (car (cadar pairs)) 'quote)
  301. ;         (memq (car (set!-exp body))
  302. ;            '(quote  lambda)))
  303. ;        (simp-letrec
  304. ;        (append! (cdr pairs)
  305. ;             (list
  306. ;                 (list (set!-id body)
  307. ;                   (set!-exp body))))
  308. ;        (set!-id body)))
  309.  
  310.        (else (list 'letrec pairs body)))))
  311.  
  312.   (simp-pairs
  313.    (lambda (old new)
  314.      (if (null? old)
  315.      (%reverse! new)
  316.      (simp-pairs (cdr old)
  317.              (cons (list (caar old)
  318.                  (simp (cadar old)))
  319.                new)))))
  320.  
  321.   (simp-car
  322.    (lambda (x)
  323.      (if (atom? x)
  324.      (list 'CAR x)
  325.      (let ((op (assq (car x) '((CAR . CAAR)(CADR . CAADR)
  326.                    (CDR . CADR)(CDDR . CADDR)
  327.                    (CDDDR . CADDDR)))))
  328.        (if op
  329.            (cons (cdr op)(cdr x))
  330.            (list 'CAR x))))))
  331.  
  332.   (simp-cdr
  333.    (lambda (x)
  334.      (if (atom? x)
  335.      (list 'CDR x)
  336.      (let ((op (assq (car x) '((CAR . CDAR)(CADR . CDADR)
  337.                    (CDR . CDDR)(CDDR . CDDDR)))))
  338.        (if op
  339.            (cons (cdr op)(cdr x))
  340.            (list 'CDR x))))))
  341.  
  342.   (simp-=
  343.    (lambda (op x y)
  344.      (if (and (eq? (car y) 'QUOTE)
  345.           (number? (cadr y)))
  346.      (let ((rop (assq op '((=  . =)  (<  . >)  (>  . <)
  347.                    (<= . >=) (>= . <=) (<> . <>)))))
  348.        (if rop
  349.            (list (cdr rop) y x)
  350.            (list op x y)))
  351.      (list op x y))))
  352.  
  353.   (simp-application
  354.    (lambda (comb)            ; COMB is already simplified
  355.      (let ((f (car comb))
  356.        (args (cdr comb)))
  357.        (cond ((atom? f)                ; primitive
  358.           (case f
  359. ;        ((%apply)  (simp-apply (car args) (cadr args)))
  360.         ((car)     (simp-car (car args)))
  361.         ((cdr)     (simp-cdr (car args)))
  362.         ((= < >  <= >= <>)
  363.                    (simp-= f (car args) (cadr args)))
  364.         (else
  365.          comb)))
  366.  
  367.                     ;; --- ((lambda () body)) ==> body
  368.  
  369.          ((and (not debug-mode)
  370.            (eq? (car f) 'lambda)
  371.            (null? args)
  372.            (null? (lambda-bvl f)))
  373.           (lambda-body f))
  374.  
  375.                     ;; --- ((lambda (a b)(foo a b))
  376.                     ;;      x y)
  377.                     ;; ==> (foo x y)
  378.  
  379.          ((and (not debug-mode)
  380.            (eq? (car f) 'lambda)
  381.            (let ((foo (car (lambda-body f))))
  382.              (cond ((atom? foo)
  383.                 (getprop foo 'pcs*opcode))
  384.                ((eq? (car foo) '#!TOKEN)
  385.                 (not (memq foo (lambda-bvl f))))
  386.                (else
  387.                 (eq? (car foo) '%%get-global%%))))
  388.            (equal? (cdr (lambda-body f))  ; (... a b)
  389.                (lambda-bvl f)))         ; (a b)
  390.           (simp-application
  391.               (cons (car (lambda-body f))
  392.             args)))
  393.  
  394.                     ;; --- ((letrec pairs body) . args)
  395.                     ;; ==> (letrec pairs (body . args))
  396.  
  397.          ((eq? (car f) 'letrec)
  398.           (simp-letrec
  399.               (letrec-pairs f)
  400.           (simp-application
  401.               `(,(letrec-body f) . ,args))))
  402.  
  403.          (else comb)))))
  404.  
  405.   (simp-args
  406.    (lambda (old new)
  407.      (if (null? old)
  408.      (%reverse! new)
  409.      (simp-args (cdr old)
  410.             (cons (simp (car old))
  411.               new)))))
  412.  
  413.   (no-se-op
  414.    (lambda (op)
  415.      (and (symbol? op)
  416.       (getprop op 'pcs*primop-handler)    ; not a 'magic' primop
  417.       (let ((opcode (getprop op 'pcs*opcode)))
  418.         (and (integer? opcode)
  419.          (positive? opcode))))))
  420.  
  421. ; data
  422.  
  423.   (debug-mode pcs-debug-mode)
  424.  
  425. ;-------!
  426.     )
  427.  (simp exp))))
  428.